home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / BBS-Archive / Dev / GNU-TILE-FORTH.lha / src / kernel.c < prev    next >
C/C++ Source or Header  |  1992-05-19  |  51KB  |  2,825 lines
  1. /*
  2.   C BASED FORTH-83 MULTI-TASKING KERNEL
  3.  
  4.   Copyright (C) 1988-1990 by Mikael R.K. Patel
  5.  
  6.   Computer Aided Design Laboratory (CADLAB)
  7.   Department of Computer and Information Science
  8.   Linkoping University
  9.   S-581 83 LINKOPING
  10.   SWEDEN
  11.  
  12.   Email: mip@ida.liu.se
  13.  
  14.   Started on: 30 June 1988
  15.  
  16.   Last updated on: 17 September 1990
  17.  
  18.   Dependencies:
  19.       (cc) kernel.h, error.h, memory.h, io.c, compiler.v,
  20.          locals.v, string.v, float.v, memory.v, queues.v,
  21.          multi-tasking.v, exceptions.v
  22.  
  23.   Description:
  24.        Virtual Forth machine and kernel code supporting multi-tasking of
  25.        light weight processes. A pure 32-bit Forth-83 Standard implementation.
  26.  
  27.        Extended with floating point numbers, argument binding and local
  28.        variables, exception handling, queue data management, multi-tasking,
  29.        symbol hiding and casting, forwarding, null terminated string,
  30.        memory allocation, file search paths, and source library module
  31.        loading.
  32.   
  33.   Note:
  34.        The kernel does not implement the block word set. All code is
  35.        stored as text files.
  36.  
  37.   Copying:
  38.        This program is free software; you can redistribute it and/or modify
  39.        it under the terms of the GNU General Public License as published by
  40.        the Free Software Foundation; either version 1, or (at your option)
  41.        any later version.
  42.  
  43.        This program is distributed in the hope that it will be useful,
  44.        but WITHOUT ANY WARRANTY; without even the implied warranty of
  45.        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  46.        GNU General Public License for more details.
  47.  
  48.        You should have received a copy of the GNU General Public License
  49.        along with this program; see the file COPYING.  If not, write to
  50.        the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  51.  
  52. */
  53.  
  54. #include "kernel.h"
  55. #include "memory.h"
  56. #include "error.h"
  57. #include "io.h"
  58.  
  59.  
  60. /* EXTERNAL DECLARATIONS */
  61.  
  62. extern VOID io_dispatch();
  63.  
  64.  
  65. /* INTERNAL FORWARD DECLARATIONS */
  66.  
  67. extern code_entry qnumber;
  68. extern code_entry terminate;
  69. extern code_entry abort_entry;
  70. extern entry toexception;
  71. extern entry span;
  72. extern entry state;
  73. extern code_entry vocabulary;
  74.  
  75.  
  76. /* VOCABULARY LISTING PARAMETERS */
  77.  
  78. #define COLUMNWIDTH 15
  79. #define LINEWIDTH 75
  80.  
  81.  
  82. /* CONTROL STRUCTURE MARKERS */
  83.  
  84. #define ELSE 1
  85. #define THEN 2
  86. #define AGAIN 4
  87. #define UNTIL 8
  88. #define WHILE 16
  89. #define REPEAT 32
  90. #define LOOP 64
  91. #define PLUSLOOP 128
  92. #define OF 256
  93. #define ENDOF 512
  94. #define ENDCASE 1024
  95. #define SEMICOLON 2048
  96.  
  97.  
  98. /* MULTI-TASKING MACHINE REGISTERS */
  99.  
  100. INT32 verbose;            /* Application or programming mode */
  101. INT32 quited;            /* Interpreter toploop state */
  102. INT32 running;            /* Task switch flag */
  103. INT32 tasking;            /* Multi-tasking flag */
  104.  
  105. TASK tp;            /* Task pointer */
  106. TASK foreground;        /* Foreground task pointer */
  107.  
  108.  
  109. /* FORTH MACHINE REGISTERS */
  110.  
  111. UNIV tos;            /* Top of stack register */
  112. PTR sp;                /* Parameter stack pointer */
  113. PTR s0;                /* Bottom of parameter stack pointer */
  114.  
  115. PTR32 ip;            /* Instruction pointer */
  116. PTR32 rp;            /* Return stack pointer */
  117. PTR32 r0;            /* Bottom of return stack pointer */
  118.  
  119. PTR32 fp;            /* Argument frame pointer */
  120. PTR32 ep;            /* Exception frame pointer */
  121.  
  122.  
  123. /* VOCABULARY SEARCH LISTS */
  124.  
  125. #define CONTEXTSIZE 64
  126.  
  127. static VOCABULARY_ENTRY current = &forth;
  128. static VOCABULARY_ENTRY context[CONTEXTSIZE] = {&forth};
  129.  
  130.  
  131. /* ENTRY LOOKUP CACHE, SIZE AND HASH FUNCTION */
  132.  
  133. #define CACHESIZE 256
  134. #define hash(s) ((s[0] + (s[1] << 4)) & (CACHESIZE - 1))
  135.  
  136. static ENTRY cache[CACHESIZE];
  137.  
  138.  
  139. /* DICTIONARY AREA FOR THREADED CODE AND DATA */
  140.  
  141. PTR32 dictionary;
  142. PTR32 dp;
  143.  
  144.  
  145. /* INTERNAL STRUCTURE AND SIZES */
  146.  
  147. static INT32 hld;
  148. static ENTRY thelast = NIL;
  149.  
  150. #define PADSIZE 84
  151. static CHAR thepad[PADSIZE];
  152.  
  153. #define TIBSIZE 256
  154. static CHAR thetib[TIBSIZE];
  155.     
  156.  
  157. /* CASTING IN INTERPRET TOP-LOOP */
  158.  
  159. #define CASTING
  160.  
  161.  
  162. /* INNER MULTI-TASKING FORTH VIRTUAL MACHINE */
  163.  
  164. VOID doinner()
  165. {
  166.     INT32 e;
  167.  
  168.     /* Exception marking and handler */
  169.     if (e = setjmp(restart)) {
  170.     spush(e, INT32);
  171.     doraise();
  172.     }
  173.     
  174.     /* Run virtual machine until task switch */
  175.     running = TRUE;
  176.     while (running) {
  177.  
  178.     /* Fetch next thread to execute */
  179.     register ENTRY p = (ENTRY) *ip++;
  180.  
  181.     /* Select on type of entry */
  182.     switch (p -> code) {
  183.       case CODE:
  184.         ((SUBR) (p -> parameter))(); 
  185.         break;
  186.       case COLON:
  187.         rpush(ip);
  188.         fjump(p -> parameter);
  189.         break;
  190.       case VARIABLE:
  191.         spush(&(p -> parameter), PTR32);
  192.         break;
  193.       case CONSTANT:
  194.         spush(p -> parameter, INT32);
  195.         break;
  196.       case VOCABULARY:
  197.         doappend((VOCABULARY_ENTRY) p);
  198.         break;
  199.       case CREATE:
  200.         spush(p -> parameter, INT32);
  201.         break;
  202.       case USER:
  203.         spush(((INT32) tp) + p -> parameter, INT32);
  204.         break;
  205.       case LOCAL:
  206.         spush(*((PTR32) (INT32) fp - p -> parameter), INT32);
  207.         break;
  208.       case FORWARD:
  209.         if (p -> parameter)
  210.         docall((ENTRY) p -> parameter);
  211.         else {
  212.         if (io_source())
  213.             (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  214.         (VOID) fprintf(io_errf, "%s: unresolved forward entry\n", p -> name);
  215.         doabort();
  216.         }
  217.         break;
  218.       case EXCEPTION:
  219.         spush(p, ENTRY);
  220.         break;
  221.       case FIELD:
  222.         unary(p -> parameter +, INT32);
  223.         break;
  224.       default: /* DOES: FORTH LEVEL INTERPRETATION */
  225.         rpush(ip);
  226.         spush(p -> parameter, INT32);
  227.         fjump(p -> code);
  228.         break;
  229.     }
  230.     }
  231. }
  232.  
  233. VOID docommand()
  234. {
  235.     INT32 e;
  236.  
  237.     /* Exception marking and handler */
  238.     if (e = setjmp(restart)) {
  239.     spush(e, INT32);
  240.     doraise();
  241.     return;
  242.     }
  243.  
  244.     /* Execute command on top of stack */
  245.     doexecute();
  246.  
  247.     /* Check if this affects the virtual machine */
  248.     if (rp != r0) {
  249.     tasking = TRUE;
  250.  
  251.     /* Run the virtual machine and allow user extension */
  252.     while (tasking) {
  253.         doinner();
  254.         io_dispatch();
  255.     }
  256.     }
  257. }
  258.  
  259. VOID docall(p)
  260.     ENTRY p;
  261. {
  262.     /* Select on type of entry */
  263.     switch (p -> code) {
  264.       case CODE:
  265.     ((SUBR) (p -> parameter))(); 
  266.     return;    
  267.       case COLON:
  268.     rpush(ip);
  269.     fjump(p -> parameter);
  270.     return;
  271.       case VARIABLE:
  272.     spush(&(p -> parameter), PTR32);
  273.     return;
  274.       case CONSTANT:
  275.     spush(p -> parameter, INT32);
  276.     return;
  277.       case VOCABULARY:
  278.     doappend((VOCABULARY_ENTRY) p);
  279.     return;
  280.       case CREATE:
  281.     spush(p -> parameter, INT32);
  282.     return;
  283.       case USER:
  284.     spush(((INT32) tp) + p -> parameter, INT32);
  285.     return;
  286.       case LOCAL:
  287.     spush(*((PTR32) (INT32) fp - p -> parameter), INT32);
  288.     return;
  289.       case FORWARD:
  290.     if (p -> parameter)
  291.         docall((ENTRY) p -> parameter);
  292.     else {
  293.         if (io_source())
  294.         (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  295.         (VOID) fprintf(io_errf, "%s: unresolved forward entry\n", p -> name);
  296.         doabort();
  297.     }
  298.     return;
  299.       case EXCEPTION:
  300.     spush(p, ENTRY);
  301.     return;
  302.       case FIELD:
  303.     unary(p -> parameter +, INT32);
  304.     return;
  305.       default: /* DOES: FORTH LEVEL INTERPRETATION */
  306.     rpush(ip);
  307.     spush(p -> parameter, INT32);
  308.     fjump(p -> code);
  309.     return;
  310.     }
  311. }
  312.  
  313. VOID doappend(p)
  314.     VOCABULARY_ENTRY p;
  315. {
  316.     INT32 v;
  317.     
  318.     /* Flush the entry cache */
  319.     spush(FALSE, BOOL);
  320.     dorestore();
  321.  
  322.     /* Check if the vocabulary is a member of the current search set */
  323.     for (v = 0; v < CONTEXTSIZE; v++)
  324.  
  325.     /* If a member then rotate the vocabulary first */
  326.     if (p == context[v]) {
  327.         for (; v; v--) context[v] = context[v - 1];
  328.         context[0] = p;
  329.         return;
  330.     }
  331.  
  332.     /* If not a member, then insert first into the search set */
  333.     for (v = CONTEXTSIZE - 1; v > 0; v--) context[v] = context[v - 1];
  334.     context[0] = p;
  335. }    
  336.  
  337.  
  338. /* VOCABULARY ROOT AND EXTERNAL VOCABULARIES */
  339.  
  340. vocabulary_entry forth = {NIL, "forth", NORMAL, VOCABULARY, (ENTRY) &vocabulary, (ENTRY) &qnumber};
  341.  
  342.  
  343. /* COMPILER EXTENSIONS */
  344.  
  345. #include "compiler.v"
  346.   
  347. NORMAL_VOCABULARY(compiler, forth, "compiler", &backwardresolve, NIL);
  348.  
  349.  
  350. /* LOCAL VARIABLES AND ARGUMENT BINDING */
  351.  
  352. #include "locals.v"
  353.  
  354. NORMAL_VOCABULARY(locals, compiler, "locals", &curlebracket, NIL);
  355.  
  356.  
  357. /* NULL TERMINATED STRING */
  358.  
  359. #include "string.v"
  360.  
  361. NORMAL_VOCABULARY(string, locals, "string", &sprint, NIL); 
  362.  
  363.  
  364. /* FLOATING POINT */
  365.  
  366. #include "float.v"
  367.  
  368. NORMAL_VOCABULARY(float_entry, string, "float", &qfloat, &qfloat); 
  369.  
  370.  
  371. /* MEMORY MANAGEMENT */
  372.  
  373. #include "memory.v"
  374.  
  375. NORMAL_VOCABULARY(memory, float_entry, "memory", &free_entry, NIL); 
  376.  
  377.  
  378. /* DOUBLE LINKED LISTS */
  379.  
  380. #include "queues.v"
  381.  
  382. NORMAL_VOCABULARY(queues, memory, "queues", &dequeue, NIL);
  383.  
  384.  
  385. /* MULTI-TASKING EXTENSIONS */
  386.  
  387. #include "multi-tasking.v"
  388.  
  389. NORMAL_VOCABULARY(multitasking, queues, "multi-tasking", &terminate, NIL);
  390.  
  391.  
  392. /* SIGNAL AND EXCEPTION MANAGEMENT */
  393.  
  394. #include "exceptions.v"
  395.  
  396. NORMAL_VOCABULARY(exceptions, multitasking, "exceptions", &raise, NIL);
  397.  
  398.  
  399. /* LOGIC: FORTH-83 VOCABULARY */
  400.  
  401. NORMAL_CONSTANT(false, exceptions, "false", FALSE);
  402.  
  403. NORMAL_CONSTANT(true, false, "true", TRUE);
  404.  
  405. VOID doboolean()
  406. {
  407.     compare(!= 0, INT32);
  408. }
  409.  
  410. NORMAL_CODE(boolean, true, "boolean", doboolean);
  411.  
  412. VOID donot()
  413. {
  414.     unary(~, INT32);
  415. }
  416.  
  417. NORMAL_CODE(not, boolean, "not", donot);
  418.  
  419. VOID doand()
  420. {
  421.     binary(&, INT32);
  422. }
  423.  
  424. NORMAL_CODE(and, not, "and", doand);
  425.  
  426. VOID door()
  427. {
  428.     binary(|, INT32);
  429. }
  430.  
  431. NORMAL_CODE(or, and, "or", door);
  432.  
  433. VOID doxor()
  434. {
  435.     binary(^, INT32);
  436. }
  437.  
  438. NORMAL_CODE(xor, or, "xor", doxor);
  439.  
  440. VOID doqwithin()
  441. {
  442.     register INT32 value;
  443.     register INT32 upper;
  444.     register INT32 lower;
  445.     
  446.     upper = spop(INT32);
  447.     lower = spop(INT32);
  448.     value = spop(INT32);
  449.     
  450.     spush((value > upper) || (value < lower) ? FALSE : TRUE, BOOL);
  451. }
  452.     
  453. NORMAL_CODE(qwithin, xor, "?within", doqwithin);
  454.  
  455.  
  456. /* STACK MANIPULATION */
  457.  
  458. VOID dodepth()
  459. {
  460.     register PTR32 t;
  461.  
  462.     t = (PTR32) sp;
  463.     spush(((PTR32) s0 - t), INT32);
  464. }
  465.  
  466. NORMAL_CODE(depth, qwithin, "depth", dodepth);
  467.  
  468. VOID dodrop()
  469. {
  470.     sdrop();
  471. }
  472.  
  473. NORMAL_CODE(drop, depth, "drop", dodrop);
  474.  
  475. VOID donip()
  476. {
  477.     snip();
  478. }
  479.  
  480. NORMAL_CODE(nip, drop, "nip", donip);
  481.  
  482. VOID doswap()
  483. {
  484.     sswap();
  485. }
  486.  
  487. NORMAL_CODE(swap, nip, "swap", doswap);
  488.  
  489. VOID dorot()
  490. {
  491.     srot();
  492. }
  493.  
  494. NORMAL_CODE(rot, swap, "rot", dorot);
  495.  
  496. VOID dodashrot()
  497. {
  498.     sdashrot();
  499. }
  500.  
  501. NORMAL_CODE(dashrot, rot, "-rot", dodashrot);
  502.  
  503. VOID doroll()
  504. {
  505.     register UNIV e;
  506.     register PTR s;
  507.  
  508.     /* Fetch roll parameters: number and element */
  509.     e = snth(tos.INT32);
  510.  
  511.     /* Roll the stack */
  512.     for (s = sp + tos.INT32; s > sp; s--) *s = *(s - 1);
  513.     sp++;
  514.     
  515.     /* And assign the new top of stack */
  516.     tos = e;
  517. }
  518.  
  519. NORMAL_CODE(roll, dashrot, "roll", doroll);
  520.  
  521. VOID doqdup()
  522. {
  523.     if (tos.INT32) sdup();
  524. }
  525.  
  526. NORMAL_CODE(qdup, roll, "?dup", doqdup);
  527.  
  528. VOID dodup()
  529. {
  530.     sdup();
  531. }
  532.  
  533. NORMAL_CODE(dup_entry, qdup, "dup", dodup);
  534.  
  535. VOID doover()
  536. {
  537.     sover();
  538. }
  539.  
  540. NORMAL_CODE(over, dup_entry, "over", doover);
  541.  
  542. VOID dotuck()
  543. {
  544.     stuck();
  545. }
  546.  
  547. NORMAL_CODE(tuck, over, "tuck", dotuck);
  548.  
  549. VOID dopick()
  550. {
  551.     tos = snth(tos.INT32);
  552. }
  553.  
  554. NORMAL_CODE(pick, tuck, "pick", dopick);
  555.  
  556. VOID dotor()
  557. {
  558.     rpush(spop(INT32));
  559. }
  560.  
  561. COMPILATION_CODE(tor, pick, ">r", dotor);
  562.  
  563. VOID dofromr()
  564. {
  565.     spush(rpop(), INT32);
  566. }
  567.  
  568. COMPILATION_CODE(fromr, tor, "r>", dofromr);
  569.  
  570. VOID docopyr()
  571. {
  572.     spush(*rp, INT32);
  573. }
  574.  
  575. COMPILATION_CODE(copyr, fromr, "r@", docopyr);
  576.  
  577. VOID dotwotor()
  578. {
  579.     rpush(spop(INT32));
  580.     rpush(spop(INT32));
  581. }
  582.  
  583. COMPILATION_CODE(twotor, copyr, "2>r", dotwotor);
  584.  
  585. VOID dotwofromr()
  586. {
  587.     spush(rpop(), INT32);
  588.     spush(rpop(), INT32);
  589. }
  590.  
  591. COMPILATION_CODE(twofromr, twotor, "2r>", dotwofromr);
  592.  
  593. VOID dotwodrop()
  594. {
  595.     sndrop(1);
  596. }
  597.  
  598. NORMAL_CODE(twodrop, twofromr, "2drop", dotwodrop);
  599.  
  600. VOID dotwoswap()
  601. {
  602.     register UNIV t;
  603.  
  604.     t = tos;
  605.     tos = snth(1);
  606.     snth(1) = t;
  607.  
  608.     t = snth(0);
  609.     snth(0) = snth(2);
  610.     snth(2) = t;
  611. }
  612.  
  613. NORMAL_CODE(twoswap, twodrop, "2swap", dotwoswap);
  614.  
  615. VOID dotworot()
  616. {
  617.     register UNIV t;
  618.  
  619.     t = tos;
  620.     tos = snth(3);
  621.     snth(3) = snth(1);
  622.     snth(1) = t;
  623.     
  624.     t = snth(0);
  625.     snth(0) = snth(4);
  626.     snth(4) = snth(2);
  627.     snth(2) = t;
  628. }
  629.  
  630. NORMAL_CODE(tworot, twoswap, "2rot", dotworot);
  631.  
  632. VOID dotwodup()
  633. {
  634.     spush(snth(1).INT32, INT32);
  635.     spush(snth(1).INT32, INT32);
  636. }
  637.  
  638. NORMAL_CODE(twodup, tworot, "2dup", dotwodup);
  639.  
  640. VOID dotwoover()
  641. {
  642.     spush(snth(3).INT32, INT32);
  643.     spush(snth(3).INT32, INT32);
  644. }
  645.  
  646. NORMAL_CODE(twoover, twodup, "2over", dotwoover);
  647.  
  648.  
  649. /* COMPARISON */
  650.  
  651. VOID dolessthan()
  652. {
  653.     relation(<, INT32);
  654. }
  655.  
  656. NORMAL_CODE(lessthan, twoover, "<", dolessthan);
  657.  
  658. VOID doequals()
  659. {
  660.     relation(==, INT32);
  661. }
  662.  
  663. NORMAL_CODE(equals, lessthan, "=", doequals);
  664.  
  665. VOID dogreaterthan()
  666. {
  667.     relation(>, INT32);
  668. }
  669.  
  670. NORMAL_CODE(greaterthan, equals, ">", dogreaterthan);
  671.  
  672. VOID dozeroless()
  673. {
  674.     compare(< 0, INT32);
  675. }
  676.  
  677. NORMAL_CODE(zeroless, greaterthan, "0<", dozeroless);
  678.  
  679. VOID dozeroequals()
  680. {
  681.     compare(== 0, INT32);
  682. }
  683.  
  684. NORMAL_CODE(zeroequals, zeroless, "0=", dozeroequals);
  685.  
  686. VOID dozerogreater()
  687. {
  688.     compare(> 0, INT32);
  689. }
  690.  
  691. NORMAL_CODE(zerogreater, zeroequals, "0>", dozerogreater);
  692.  
  693. VOID doulessthan()
  694. {
  695.     relation(<, NUM32);
  696. }
  697.  
  698. NORMAL_CODE(ulessthan, zerogreater, "u<", doulessthan);
  699.  
  700.  
  701. /* CONSTANTS */
  702.  
  703. NORMAL_CONSTANT(nil, ulessthan, "nil", NIL);
  704.  
  705. NORMAL_CONSTANT(minusfour, nil, "-4", -4);
  706.  
  707. NORMAL_CONSTANT(minustwo, minusfour, "-2", -2);
  708.  
  709. NORMAL_CONSTANT(minusone, minustwo, "-1", -1);
  710.  
  711. NORMAL_CONSTANT(zero, minusone, "0", 0);
  712.  
  713. NORMAL_CONSTANT(one, zero, "1", 1);
  714.  
  715. NORMAL_CONSTANT(two, one, "2", 2);
  716.  
  717. NORMAL_CONSTANT(four, two, "4", 4);
  718.  
  719.  
  720. /* ARITHMETRIC */
  721.  
  722. VOID doplus()
  723. {
  724.     binary(+, INT32);
  725. }
  726.  
  727. NORMAL_CODE(plus, four, "+", doplus);
  728.  
  729. VOID dominus()
  730. {
  731.     binary(-, INT32);
  732. }
  733.  
  734. NORMAL_CODE(minus, plus, "-", dominus);
  735.  
  736. VOID dooneplus()
  737. {
  738.     unary(++, INT32);
  739. }
  740.  
  741. NORMAL_CODE(oneplus, minus, "1+", dooneplus);
  742.  
  743. VOID dooneminus()
  744. {
  745.     unary(--, INT32);
  746. }
  747.  
  748. NORMAL_CODE(oneminus, oneplus, "1-", dooneminus);
  749.  
  750. VOID dotwoplus()
  751. {
  752.     unary(2 +, INT32);
  753. }
  754.  
  755. NORMAL_CODE(twoplus, oneminus, "2+", dotwoplus);
  756.  
  757. VOID dotwominus()
  758. {
  759.     unary(-2 +, INT32);
  760. }
  761.  
  762. NORMAL_CODE(twominus, twoplus, "2-", dotwominus);
  763.  
  764. VOID dotwotimes()
  765. {
  766.     tos.INT32 <<= 1;
  767. }
  768.  
  769. NORMAL_CODE(twotimes, twominus, "2*", dotwotimes);
  770.  
  771. VOID doleftshift()
  772. {
  773.     binary(<<, INT32);
  774. }
  775.  
  776. NORMAL_CODE(leftshift, twotimes, "<<", doleftshift);
  777.  
  778. VOID dotimes()
  779. {
  780.     binary(*, INT32);
  781. }
  782.  
  783. NORMAL_CODE(times_entry, leftshift, "*", dotimes);
  784.  
  785. VOID doumtimes()
  786. {
  787.     binary(*, NUM32);
  788. }
  789.  
  790. NORMAL_CODE(utimes_entry, times_entry, "um*", doumtimes);
  791.  
  792. VOID doumdividemod()
  793. {
  794.     register NUM32 t;
  795.  
  796.     t = snth(0).NUM32;
  797.     snth(0).NUM32 = t % tos.NUM32;
  798.     tos.NUM32 = t / tos.NUM32;
  799. }
  800.  
  801. NORMAL_CODE(umdividemod, utimes_entry, "um/mod", doumdividemod);
  802.  
  803. VOID dotwodivide()
  804. {
  805.     tos.INT32 >>= 1;
  806. }
  807.  
  808. NORMAL_CODE(twodivide, umdividemod, "2/", dotwodivide);
  809.  
  810. VOID dorightshift()
  811. {
  812.     binary(>>, INT32);
  813. }
  814.  
  815. NORMAL_CODE(rightshift, twodivide, ">>", dorightshift);
  816.  
  817. VOID dodivide()
  818. {
  819.     binary(/, INT32);
  820. }
  821.  
  822. NORMAL_CODE(divide, rightshift, "/", dodivide);
  823.  
  824. VOID domod()
  825. {
  826.     binary(%, INT32);
  827. }
  828.  
  829. NORMAL_CODE(mod, divide, "mod", domod);
  830.  
  831. VOID dodividemod()
  832. {
  833.     register INT32 t;
  834.  
  835.     t = snth(0).INT32;
  836.     snth(0).INT32 = t % tos.INT32;
  837.     tos.INT32 = t / tos.INT32;
  838. }
  839.  
  840. NORMAL_CODE(dividemod, mod, "/mod", dodividemod);
  841.  
  842. VOID dotimesdividemod()
  843. {
  844.     register INT32 t;
  845.  
  846.     t = spop(INT32);
  847.     tos.INT32 = tos.INT32 * snth(0).INT32;
  848.     snth(0).INT32 = tos.INT32 % t;
  849.     tos.INT32 = tos.INT32 / t;
  850. }
  851.  
  852. NORMAL_CODE(timesdividemod, dividemod, "*/mod", dotimesdividemod);
  853.  
  854. VOID dotimesdivide()
  855. {
  856.     register INT32 t;
  857.  
  858.     t = spop(INT32);
  859.     binary(*, INT32);
  860.     spush(t, INT32);
  861.     binary(/, INT32);
  862. }
  863.  
  864. NORMAL_CODE(timesdivide, timesdividemod, "*/", dotimesdivide);
  865.  
  866. VOID domin()
  867. {
  868.     register INT32 t;
  869.  
  870.     t = spop(INT32);
  871.     tos.INT32 = (t < tos.INT32 ? t : tos.INT32);
  872. }
  873.  
  874. NORMAL_CODE(min, timesdivide, "min", domin);
  875.  
  876. VOID domax()
  877. {
  878.     register INT32 t;
  879.  
  880.     t = spop(INT32);
  881.     tos.INT32 = (t > tos.INT32 ? t : tos.INT32);
  882. }
  883.  
  884. NORMAL_CODE(max, min, "max", domax);
  885.  
  886. VOID doabs()
  887. {
  888.     tos.INT32 = (tos.INT32 < 0 ? - tos.INT32 : tos.INT32);
  889. }
  890.  
  891. NORMAL_CODE(abs_entry, max, "abs", doabs);
  892.  
  893. VOID donegate()
  894. {
  895.     unary(-, INT32);
  896. }
  897.  
  898. NORMAL_CODE(negate, abs_entry, "negate", donegate);
  899.  
  900.  
  901. /* MEMORY */
  902.  
  903. VOID dofetch()
  904. {
  905.     unary(*(PTR32), INT32);
  906. }
  907.  
  908. NORMAL_CODE(fetch, negate, "@", dofetch);
  909.  
  910. VOID dostore()
  911. {
  912.     register PTR32 t;
  913.  
  914.     t = spop(PTR32);
  915.     *t = spop(INT32);
  916. }
  917.  
  918. NORMAL_CODE(store, fetch, "!", dostore);
  919.  
  920. VOID dowfetch()
  921. {
  922.     unary(*(NUM16 *), NUM32);
  923. }
  924.  
  925. NORMAL_CODE(wfetch, store, "w@", dowfetch);
  926.  
  927. VOID dolesswfetch()
  928. {
  929.     unary(*(PTR16), INT32);
  930. }
  931.  
  932. NORMAL_CODE(lesswfetch, wfetch, "<w@", dolesswfetch);
  933.  
  934. VOID dowstore()
  935. {
  936.     register PTR16 t;
  937.  
  938.     t = spop(PTR16);
  939.     *t = spop(INT32);
  940. }
  941.  
  942. NORMAL_CODE(wstore, lesswfetch, "w!", dowstore);
  943.  
  944. VOID docfetch()
  945. {
  946.     unary(*(NUM8 *), NUM32);
  947. }
  948.  
  949. NORMAL_CODE(cfetch, wstore, "c@", docfetch);
  950.  
  951. VOID dolesscfetch()
  952. {
  953.     unary(*(PTR8), INT32);
  954. }
  955.  
  956. NORMAL_CODE(lesscfetch, cfetch, "<c@", dolesscfetch);
  957.  
  958. VOID docstore()
  959. {
  960.     register PTR8 t;
  961.  
  962.     t = spop(PTR8);
  963.     *t = spop(INT32);
  964. }
  965.  
  966. NORMAL_CODE(cstore, lesscfetch, "c!", docstore);
  967.  
  968. VOID doffetch()
  969. {
  970.     register INT32 pos;
  971.     register INT32 width;
  972.  
  973.     width = spop(INT32);
  974.     pos = spop(INT32);
  975.     if (width < sizeof(INT32) * 8)
  976.     tos.INT32 = (tos.INT32 >> pos) & ~(-1 << width);
  977. }
  978.  
  979. NORMAL_CODE(ffetch, cstore, "f@", doffetch);
  980.  
  981. VOID dolessffetch()
  982. {
  983.     register INT32 pos;
  984.     register INT32 width;
  985.  
  986.     width = spop(INT32);
  987.     pos = spop(INT32);
  988.     if (width < sizeof(INT32) * 8) {
  989.     tos.INT32 = (tos.INT32 >> pos) & ~(-1 << width);
  990.     if ((1 << (width - 1)) & tos.INT32) {
  991.         tos.INT32 = (tos.INT32) | (-1 << width);
  992.     }
  993.     }
  994. }
  995.  
  996. NORMAL_CODE(lessffetch, ffetch, "<f@", dolessffetch);
  997.  
  998. VOID dofstore()
  999. {
  1000.     register INT32 pos;
  1001.     register INT32 width;
  1002.     register INT32 value;
  1003.  
  1004.     width = spop(INT32);
  1005.     pos = spop(INT32);
  1006.     value = spop(INT32);
  1007.     tos.INT32 = ((tos.INT32 & ~(-1 << width)) << pos) | (value & ~((~(-1 << width)) << pos));
  1008. }
  1009.  
  1010. NORMAL_CODE(fstore, lessffetch, "f!", dofstore);
  1011.  
  1012. VOID dobfetch()
  1013. {
  1014.     register INT32 bit;
  1015.  
  1016.     bit = spop(INT32);
  1017.     tos.INT32 = (((tos.INT32 >> bit) & 1) ? TRUE : FALSE);
  1018. }
  1019.  
  1020. NORMAL_CODE(bfetch, fstore, "b@", dobfetch);
  1021.  
  1022. VOID dobstore()
  1023. {
  1024.     register INT32 bit;
  1025.     register INT32 value;
  1026.  
  1027.     bit = spop(INT32);
  1028.     value = spop(INT32);
  1029.     tos.INT32 = (tos.INT32 ? (value | (1 << bit)) : (value & ~(1 << bit)));
  1030. }
  1031.  
  1032. NORMAL_CODE(bstore, bfetch, "b!", dobstore);
  1033.  
  1034. VOID doplusstore()
  1035. {
  1036.     register PTR32 t;
  1037.  
  1038.     t = spop(PTR32);
  1039.     *t += spop(INT32);
  1040. }
  1041.  
  1042. NORMAL_CODE(plusstore, bstore, "+!", doplusstore);
  1043.  
  1044. VOID dotwofetch()
  1045. {
  1046.     register PTR32 t;
  1047.  
  1048.     t = tos.PTR32;
  1049.     spush(*t++, INT32);
  1050.     snth(0).INT32 = *t;
  1051. }
  1052.  
  1053. NORMAL_CODE(twofetch, plusstore, "2@", dotwofetch);
  1054.  
  1055. VOID dotwostore()
  1056. {
  1057.     register PTR32 t;
  1058.  
  1059.     t = spop(PTR32);
  1060.     *t++ = spop(INT32);
  1061.     *t = spop(INT32);
  1062. }
  1063.  
  1064. NORMAL_CODE(twostore, twofetch, "2!", dotwostore);
  1065.  
  1066.  
  1067. /* STRINGS */
  1068.  
  1069. VOID docmove()
  1070. {
  1071.     register INT32 n;
  1072.     register CSTR to;
  1073.     register CSTR from;
  1074.  
  1075.     n = spop(INT32);
  1076.     to = spop(CSTR);
  1077.     from = spop(CSTR);
  1078.  
  1079.     while (--n != -1) *to++ = *from++;
  1080. }
  1081.  
  1082. NORMAL_CODE(cmove, twostore, "cmove", docmove);
  1083.  
  1084. VOID docmoveup()
  1085. {
  1086.     register INT32 n;
  1087.     register CSTR to;
  1088.     register CSTR from;
  1089.  
  1090.     n = spop(INT32);
  1091.     to = spop(CSTR);
  1092.     from = spop(CSTR);
  1093.  
  1094.     to += n;
  1095.     from += n;
  1096.     while (--n != -1) *--to = *--from;
  1097. }
  1098.  
  1099. NORMAL_CODE(cmoveup, cmove, "cmove>", docmoveup);
  1100.  
  1101. VOID dofill()
  1102. {
  1103.     register INT32 with;
  1104.     register INT32 n;
  1105.     register CSTR from;
  1106.  
  1107.     with = spop(INT32);
  1108.     n = spop(INT32);
  1109.     from = spop(CSTR);
  1110.  
  1111.     while (--n != -1) *from++ = with;
  1112. }
  1113.  
  1114. NORMAL_CODE(fill, cmoveup, "fill", dofill);
  1115.  
  1116. VOID docount()
  1117. {
  1118.     register CSTR t;
  1119.  
  1120.     t = spop(CSTR);
  1121.     spush(*t++, INT32);
  1122.     spush(t, CSTR);
  1123. }
  1124.  
  1125. NORMAL_CODE(count, fill, "count", docount);
  1126.  
  1127. VOID dobounds()
  1128. {
  1129.     register CSTR n;
  1130.  
  1131.     n = snth(0).CSTR;
  1132.     snth(0).CSTR = snth(0).CSTR + tos.INT32;
  1133.     tos.CSTR = n;
  1134. }
  1135.  
  1136. NORMAL_CODE(bounds, count, "bounds", dobounds);
  1137.  
  1138. VOID dodashtrailing()
  1139. {
  1140.     register CSTR p;
  1141.  
  1142.     p = snth(0).CSTR + tos.INT32;
  1143.     tos.INT32 += 1;
  1144.     while (--tos.INT32 && (*--p == ' '));
  1145. }
  1146.  
  1147. NORMAL_CODE(dashtrailing, bounds, "-trailing", dodashtrailing);
  1148.  
  1149. VOID dodashmatch()
  1150. {
  1151.     register INT32 n;
  1152.     register CSTR s;
  1153.     register CSTR t;
  1154.     
  1155.     n = spop(INT32);
  1156.     s = spop(CSTR);
  1157.     t = spop(CSTR);
  1158.  
  1159.     if (n) {
  1160.     while ((n) && (*s++ == *t++)) n--;
  1161.     spush(n ? TRUE : FALSE, BOOL);
  1162.     }
  1163.     else {
  1164.     spush(TRUE, BOOL);
  1165.     }
  1166. }
  1167.  
  1168. NORMAL_CODE(dashmatch, dashtrailing, "-match", dodashmatch);
  1169.  
  1170.  
  1171. /* NUMERICAL CONVERSION */
  1172.  
  1173. NORMAL_VARIABLE(base, dashmatch, "base", 10);
  1174.  
  1175. VOID dobinary()
  1176. {
  1177.     base.parameter = 2;
  1178. }
  1179.  
  1180. NORMAL_CODE(binary_entry, base, "binary", dobinary);
  1181.  
  1182. VOID dooctal()
  1183. {
  1184.     base.parameter = 8;
  1185. }
  1186.  
  1187. NORMAL_CODE(octal, binary_entry, "octal", dooctal);
  1188.  
  1189. VOID dodecimal()
  1190. {
  1191.     base.parameter = 10;
  1192. }
  1193.  
  1194. NORMAL_CODE(decimal, octal, "decimal", dodecimal);
  1195.  
  1196. VOID dohex()
  1197. {
  1198.     base.parameter = 16;
  1199. }
  1200.  
  1201. NORMAL_CODE(hex, decimal, "hex", dohex);
  1202.  
  1203. VOID doconvert()
  1204. {
  1205.     register CHAR c;
  1206.     register INT32 b;
  1207.     register INT32 n;
  1208.     
  1209.     b = base.parameter;
  1210.     n = snth(0).INT32;
  1211.  
  1212.     for (;;) {
  1213.     c = *tos.CSTR;
  1214.     if (c < '0' || c > 'z' || (c > '9' && c < 'a')) {
  1215.         snth(0).INT32 = n;
  1216.         return;
  1217.     }
  1218.     else {
  1219.         if (c > '9') c = c - 'a' + ':';
  1220.         c = c - '0';
  1221.         if (c < 0 || c >= b) {
  1222.         snth(0).INT32 = n;
  1223.         return;
  1224.         }
  1225.         n = (n * b) + c;
  1226.         tos.INT32 += 1;
  1227.     }
  1228.     }
  1229. }
  1230.  
  1231. NORMAL_CODE(convert, hex, "convert", doconvert);
  1232.  
  1233. VOID dolesssharp()
  1234. {
  1235.     hld = (INT32) thepad + PADSIZE;
  1236. }
  1237.  
  1238. NORMAL_CODE(lesssharp, convert, "<#", dolesssharp);
  1239.  
  1240. VOID dosharp()
  1241. {
  1242.     register NUM32 n;
  1243.  
  1244.     n = tos.NUM32;
  1245.     tos.NUM32 = n / (NUM32) base.parameter;
  1246.     n = n % (NUM32) base.parameter;
  1247.     *(CSTR) --hld = n + ((n > 9) ? 'a' - 10 : '0');
  1248. }
  1249.  
  1250. NORMAL_CODE(sharp, lesssharp, "#", dosharp);
  1251.  
  1252. VOID dosharps()
  1253. {
  1254.     do { dosharp(); } while (tos.INT32);
  1255. }
  1256.  
  1257. NORMAL_CODE(sharps, sharp, "#s", dosharps);
  1258.  
  1259. VOID dohold()
  1260. {
  1261.     *(CSTR) --hld = spop(INT32);
  1262. }
  1263.  
  1264. NORMAL_CODE(hold, sharps, "hold", dohold);
  1265.  
  1266. VOID dosign()
  1267. {
  1268.     INT32 flag;
  1269.  
  1270.     flag = spop(INT32);
  1271.     if (flag < 0) *(CSTR) --hld = '-';
  1272. }
  1273.  
  1274. NORMAL_CODE(sign, hold, "sign", dosign);
  1275.  
  1276. VOID dosharpgreater()
  1277. {
  1278.     tos.INT32 = hld;
  1279.     spush((INT32) thepad + PADSIZE - hld, INT32);
  1280. }
  1281.  
  1282. NORMAL_CODE(sharpgreater, sign, "#>", dosharpgreater);
  1283.  
  1284. VOID doqnumber()
  1285. {
  1286.     register CSTR s0;
  1287.     register CSTR s1;
  1288.     
  1289.     s0 = spop(CSTR);
  1290.     spush(0, INT32);
  1291.     if (*s0 == '-') {
  1292.     spush(s0 + 1, CSTR);
  1293.     }
  1294.     else {
  1295.     spush(s0, CSTR);
  1296.     }
  1297.     doconvert();
  1298.     s1 = spop(CSTR);
  1299.     if (*s1 == '\0') {
  1300.     if (*s0 == '-') unary(-, INT32);
  1301.     spush(TRUE, BOOL);
  1302.     }
  1303.     else {
  1304.     tos.CSTR = s0;
  1305.     spush(FALSE, BOOL);
  1306.     }
  1307. }
  1308.  
  1309. NORMAL_CODE(qnumber, sharpgreater, "?number", doqnumber);
  1310.  
  1311.  
  1312. /* CONTROL STRUCTURES */
  1313.  
  1314. INT32 docheck(this)
  1315.     INT this;
  1316. {
  1317.     ENTRY last;
  1318.     INT32 follow = spop(INT32);
  1319.  
  1320.     /* Check if the symbol is in the follow set */
  1321.     if (this & follow) {
  1322.  
  1323.     /* Return true is so */
  1324.     return TRUE;
  1325.     }
  1326.     else {
  1327.  
  1328.     /* Else report a control structure error */
  1329.     dolast();
  1330.     last = spop(ENTRY);
  1331.     if (io_source())
  1332.         (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  1333.     (VOID) fprintf(io_errf, "%s: illegal control structure\n", last -> name);
  1334.     doabort();
  1335.  
  1336.     return FALSE;
  1337.     }
  1338. }
  1339.  
  1340. VOID dodo()
  1341. {
  1342.     spush(&parendo, CODE_ENTRY);
  1343.     dothread();
  1344.     doforwardmark();
  1345.     dobackwardmark();
  1346.     spush(LOOP+PLUSLOOP, INT32);
  1347. }
  1348.  
  1349. COMPILATION_IMMEDIATE_CODE(do_entry, qnumber, "do", dodo);
  1350.  
  1351. VOID doqdo()
  1352. {
  1353.     spush(&parenqdo, CODE_ENTRY);
  1354.     dothread();
  1355.     doforwardmark();
  1356.     dobackwardmark();
  1357.     spush(LOOP+PLUSLOOP, INT32);
  1358. }
  1359.  
  1360. COMPILATION_IMMEDIATE_CODE(qdo_entry, do_entry, "?do", doqdo);
  1361.  
  1362. VOID doloop()
  1363. {
  1364.     if (docheck(LOOP)) {
  1365.     spush(&parenloop, CODE_ENTRY);
  1366.     dothread();
  1367.     dobackwardresolve();
  1368.     doforwardresolve();
  1369.     }
  1370. }
  1371.  
  1372. COMPILATION_IMMEDIATE_CODE(loop, qdo_entry, "loop", doloop);
  1373.  
  1374. VOID doplusloop()
  1375. {
  1376.     if (docheck(PLUSLOOP)) {
  1377.     spush(&parenplusloop, CODE_ENTRY);
  1378.     dothread();
  1379.     dobackwardresolve();
  1380.     doforwardresolve();
  1381.     }
  1382. }
  1383.  
  1384. COMPILATION_IMMEDIATE_CODE(plusloop, loop, "+loop", doplusloop);
  1385.  
  1386. VOID doleave()
  1387. {
  1388.     rndrop(2);
  1389.     fjump(rpop());
  1390.     fbranch(*ip);
  1391. }
  1392.  
  1393. COMPILATION_CODE(leave, plusloop, "leave", doleave);
  1394.  
  1395. VOID doi()
  1396. {
  1397.     spush(rnth(1), INT32);
  1398. }
  1399.  
  1400. COMPILATION_CODE(i_entry, leave,"i", doi);
  1401.  
  1402. VOID doj()
  1403. {
  1404.     spush(rnth(4), INT32);
  1405. }
  1406.  
  1407. COMPILATION_CODE(j_entry, i_entry, "j", doj);
  1408.  
  1409. VOID doif()
  1410. {
  1411.     spush(&parenqbranch, CODE_ENTRY);
  1412.     dothread();
  1413.     doforwardmark();
  1414.     spush(ELSE+THEN, INT32);
  1415. }
  1416.  
  1417. COMPILATION_IMMEDIATE_CODE(if_entry, j_entry, "if", doif);
  1418.  
  1419. VOID doelse()
  1420. {
  1421.     if (docheck(ELSE)) {
  1422.     spush(&parenbranch, CODE_ENTRY);
  1423.     dothread();
  1424.     doforwardmark();
  1425.     doswap();
  1426.     doforwardresolve();
  1427.     spush(THEN, INT32);
  1428.     }
  1429. }
  1430.  
  1431. COMPILATION_IMMEDIATE_CODE(else_entry, if_entry, "else", doelse);
  1432.  
  1433. VOID dothen()
  1434. {
  1435.     if (docheck(THEN)) {
  1436.     doforwardresolve();
  1437.     }
  1438. }
  1439.  
  1440. COMPILATION_IMMEDIATE_CODE(then_entry, else_entry, "then", dothen);
  1441.  
  1442. VOID docase()
  1443. {
  1444.     spush(0, INT32);
  1445.     spush(OF+ENDCASE, INT32);
  1446. }
  1447.  
  1448. COMPILATION_IMMEDIATE_CODE(case_entry, then_entry, "case", docase);
  1449.  
  1450. VOID doof()
  1451. {
  1452.     if (docheck(OF)) {
  1453.     spush(&over, CODE_ENTRY);
  1454.     dothread();
  1455.     spush(&equals, CODE_ENTRY);
  1456.     dothread();
  1457.     spush(&parenqbranch, CODE_ENTRY);
  1458.     dothread();
  1459.     doforwardmark();
  1460.     spush(&drop, CODE_ENTRY);
  1461.     dothread();
  1462.     spush(ENDOF, INT32);
  1463.     }
  1464. }
  1465.  
  1466. COMPILATION_IMMEDIATE_CODE(of_entry, case_entry, "of", doof);
  1467.  
  1468. VOID doendof()
  1469. {
  1470.     if (docheck(ENDOF)) {
  1471.     spush(&parenbranch, CODE_ENTRY);
  1472.     dothread();
  1473.     doforwardmark();
  1474.     doswap();
  1475.     doforwardresolve();
  1476.     spush(OF+ENDCASE, INT32);
  1477.     }
  1478. }
  1479.  
  1480. COMPILATION_IMMEDIATE_CODE(endof, of_entry, "endof", doendof);
  1481.  
  1482. VOID doendcase()
  1483. {
  1484.     if (docheck(ENDCASE)) {
  1485.     spush(&drop, CODE_ENTRY);
  1486.     dothread();
  1487.     while (tos.INT32) doforwardresolve();
  1488.     dodrop();
  1489.     }
  1490. }
  1491.  
  1492. COMPILATION_IMMEDIATE_CODE(endcase, endof, "endcase", doendcase);
  1493.  
  1494. VOID dobegin()
  1495. {
  1496.     dobackwardmark();
  1497.     spush(AGAIN+UNTIL+WHILE, INT32);
  1498. }
  1499.  
  1500. COMPILATION_IMMEDIATE_CODE(begin, endcase, "begin", dobegin);
  1501.  
  1502. VOID dountil()
  1503. {
  1504.     if (docheck(UNTIL)) {
  1505.     spush(&parenqbranch, CODE_ENTRY);
  1506.     dothread();
  1507.     dobackwardresolve();
  1508.     }
  1509. }
  1510.  
  1511. COMPILATION_IMMEDIATE_CODE(until, begin, "until", dountil);
  1512.  
  1513. VOID dowhile()
  1514. {
  1515.     if (docheck(WHILE)) {
  1516.     spush(&parenqbranch, CODE_ENTRY);
  1517.     dothread();
  1518.     doforwardmark();
  1519.     spush(REPEAT, INT32);
  1520.     }
  1521. }
  1522.  
  1523. COMPILATION_IMMEDIATE_CODE(while_entry, until, "while", dowhile);
  1524.  
  1525. VOID dorepeat()
  1526. {
  1527.     if (docheck(REPEAT)) {
  1528.     spush(&parenbranch, CODE_ENTRY);
  1529.     dothread();
  1530.     doswap();
  1531.     dobackwardresolve();
  1532.     doforwardresolve();
  1533.     }
  1534. }
  1535.  
  1536. COMPILATION_IMMEDIATE_CODE(repeat, while_entry, "repeat", dorepeat);
  1537.  
  1538. VOID doagain()
  1539. {
  1540.     if (docheck(AGAIN)) { 
  1541.     spush(&parenbranch, CODE_ENTRY);
  1542.     dothread();
  1543.     dobackwardresolve();
  1544.     }
  1545. }
  1546.  
  1547. COMPILATION_IMMEDIATE_CODE(again, repeat, "again", doagain);
  1548.  
  1549. VOID dorecurse()
  1550. {
  1551.     dolast();
  1552.     dothread();
  1553. }
  1554.  
  1555. COMPILATION_IMMEDIATE_CODE(recurse, again, "recurse", dorecurse);
  1556.  
  1557. VOID dotailrecurse()
  1558. {
  1559.     if (theframed) {
  1560.      spush(&parenunlink, CODE_ENTRY);
  1561.     dothread();
  1562.     }
  1563.     dolast();
  1564.     dotobody();
  1565.     spush(&parenbranch, CODE_ENTRY);
  1566.     dothread();
  1567.     dobackwardresolve();
  1568. }
  1569.  
  1570. COMPILATION_IMMEDIATE_CODE(tailrecurse, recurse, "tail-recurse", dotailrecurse);
  1571.  
  1572. VOID doexit()
  1573. {
  1574.     fsemicolon();
  1575. }
  1576.  
  1577. COMPILATION_CODE(exit_entry, tailrecurse, "exit", doexit);
  1578.  
  1579. VOID doexecute()
  1580. {
  1581.     ENTRY t;
  1582.  
  1583.     t = spop(ENTRY);
  1584.     docall(t);
  1585. }
  1586.  
  1587. NORMAL_CODE(execute, exit_entry, "execute", doexecute);
  1588.  
  1589. VOID dobye()
  1590. {
  1591.     quited = FALSE;
  1592. }
  1593.  
  1594. NORMAL_CODE(bye, execute, "bye", dobye);
  1595.  
  1596.  
  1597. /* TERMINAL INPUT-OUTPUT */
  1598.  
  1599. VOID dodot()
  1600. {
  1601.     if (tos.INT32 < 0) {
  1602.     (VOID) fputc('-', io_outf);
  1603.     unary(-, INT32);
  1604.     }
  1605.     doudot();
  1606. }
  1607.  
  1608. NORMAL_CODE(dot, bye, ".", dodot);
  1609.  
  1610. VOID dodotr()
  1611. {
  1612.     INT32 s, t;
  1613.  
  1614.     t = spop(INT32);
  1615.     s = tos.INT32;
  1616.     doabs();
  1617.     dolesssharp();
  1618.     dosharps();
  1619.     spush(s, INT32);
  1620.     dosign();
  1621.     dosharpgreater();
  1622.     spush(t, INT32);
  1623.     sover();
  1624.     dominus();
  1625.     dospaces();
  1626.     dotype();
  1627. }
  1628.  
  1629. NORMAL_CODE(dotr, dot, ".r", dodotr);
  1630.  
  1631. VOID doudot()
  1632. {
  1633.     dolesssharp();
  1634.     dosharps();
  1635.     dosharpgreater();
  1636.     dotype();
  1637.     dospace();
  1638. }
  1639.  
  1640. NORMAL_CODE(udot, dotr, "u.", doudot);
  1641.  
  1642. VOID doudotr()
  1643. {
  1644.     INT32 t;
  1645.  
  1646.     t = spop(INT32);
  1647.     dolesssharp();
  1648.     dosharps();
  1649.     dosharpgreater();
  1650.     spush(t, INT32);
  1651.     sover();
  1652.     dominus();
  1653.     dospaces();
  1654.     dotype();
  1655. }
  1656.  
  1657. NORMAL_CODE(udotr, udot, "u.r", doudotr);
  1658.  
  1659. VOID doascii()
  1660. {
  1661.     spush(' ', INT32);
  1662.     doword();
  1663.     docfetch();
  1664.     doliteral();
  1665. }
  1666.  
  1667. IMMEDIATE_CODE(ascii, udotr, "ascii", doascii);
  1668.  
  1669. VOID dodotquote()
  1670. {
  1671.     (VOID) io_scan(thetib, '"');
  1672.     spush(thetib, CSTR);
  1673.     dosdup();
  1674.     snip();
  1675.     spush(&parendotquote, CODE_ENTRY);
  1676.     dothread();
  1677.     docomma();
  1678. }
  1679.  
  1680. COMPILATION_IMMEDIATE_CODE(dotquote, ascii, ".\"", dodotquote);
  1681.  
  1682. VOID dodotparen()
  1683. {
  1684.     (VOID) io_scan(thetib, ')'); 
  1685.     spush(thetib, CSTR);
  1686.     dosprint();
  1687. }
  1688.  
  1689. IMMEDIATE_CODE(dotparen, dotquote, ".(", dodotparen);
  1690.  
  1691. VOID dodots()
  1692. {
  1693.     register PTR s;
  1694.  
  1695.     /* Print the stack depth */
  1696.     (VOID) fprintf(io_outf, "[%d] ", s0 - sp);
  1697.  
  1698.     /* Check if there are any elements on the stack */
  1699.     if (s0 - sp > 0) {
  1700.  
  1701.     /* Print them and don't forget top of stack */
  1702.     for (s = s0 - 2; s >= sp; s--) {
  1703.         (VOID) fprintf(io_outf, "\\");
  1704.         spush(s -> INT32, INT32);
  1705.         if (tos.INT32 < 0) {
  1706.         (VOID) fputc('-', io_outf);
  1707.         unary(-, INT32);
  1708.         }
  1709.         dolesssharp();
  1710.         dosharps();
  1711.         dosharpgreater();
  1712.         dotype();
  1713.     }
  1714.     (VOID) fprintf(io_outf, "\\");
  1715.     dodup();
  1716.     dodot();
  1717.     }
  1718. }
  1719.  
  1720. NORMAL_CODE(dots, dotparen, ".s", dodots);
  1721.  
  1722. VOID docr()
  1723. {
  1724.     (VOID) fputc('\n', io_outf);
  1725. }
  1726.  
  1727. NORMAL_CODE(cr, dots, "cr", docr);
  1728.  
  1729. VOID doemit()
  1730. {
  1731.     CHAR c;
  1732.  
  1733.     c = (CHAR) spop(INT32);
  1734.     (VOID) fputc(c, io_outf);
  1735. }
  1736.  
  1737. NORMAL_CODE(emit, cr, "emit", doemit);
  1738.  
  1739. VOID dotype()
  1740. {
  1741.     register INT32 n;
  1742.     register CSTR s;
  1743.  
  1744.     n = spop(INT32);
  1745.     s = spop(CSTR);
  1746.     while (n--) (VOID) fputc(*s++, io_outf);
  1747. }
  1748.  
  1749. NORMAL_CODE(type, emit, "type", dotype);
  1750.  
  1751. VOID dospace()
  1752. {
  1753.     (VOID) fputc(' ', io_outf);
  1754. }
  1755.  
  1756. NORMAL_CODE(space, type, "space", dospace);
  1757.  
  1758. VOID dospaces()
  1759. {
  1760.     register INT32 n;
  1761.  
  1762.     n = spop(INT32);
  1763.     while (n-- > 0) (VOID) fputc(' ', io_outf);
  1764. }
  1765.  
  1766. NORMAL_CODE(spaces, space, "spaces", dospaces);
  1767.  
  1768. VOID dokey()
  1769. {
  1770.     spush(io_getchar(), INT32);
  1771. }
  1772.  
  1773. NORMAL_CODE(key, spaces, "key", dokey);
  1774.  
  1775. VOID doexpect()
  1776. {
  1777.     register CHAR  c;
  1778.     register CSTR s0;
  1779.     register CSTR s1;
  1780.     register INT32  n;
  1781.     
  1782.     /* Pop buffer pointer and size */
  1783.     n = spop(INT32);
  1784.     s0 = s1 = spop(CSTR);
  1785.     
  1786.     /* Fill buffer until end of line or buffer */
  1787.     while (io_not_eof() && (n-- > 0) && ((c = io_getchar()) != '\n')) *s1++ = c;
  1788.  
  1789.     io_newline();
  1790.  
  1791.     /* Set span to number of characters received */
  1792.     span.parameter = (INT32) (s1 - s0);
  1793. }
  1794.  
  1795. NORMAL_CODE(expect, key, "expect", doexpect);
  1796.  
  1797. NORMAL_VARIABLE(span, expect, "span", 0);
  1798.  
  1799. VOID doline()
  1800. {
  1801.     spush(io_line(), INT32);
  1802. }
  1803.  
  1804. NORMAL_CODE(line, span, "line", doline);
  1805.  
  1806. VOID dosource()
  1807. {
  1808.     spush(io_source(), CSTR);
  1809. }
  1810.  
  1811. NORMAL_CODE(source, line, "source", dosource);
  1812.  
  1813.  
  1814. /* PROGRAM BEGINNING AND TERMINATION */
  1815.  
  1816. VOID doforth83()
  1817. {
  1818.  
  1819. }
  1820.  
  1821. NORMAL_CODE(forth83, source, "forth-83", doforth83);
  1822.     
  1823. VOID dointerpret()
  1824. {
  1825.     INT32 flag;            /* Flag value returned by for words */
  1826.  
  1827. #ifdef CASTING
  1828.     INT32 cast;            /* Casting operation flag */
  1829. #endif
  1830.     
  1831.     quited = TRUE;        /* Iterate until bye or end of input */
  1832.  
  1833.     while (quited) {
  1834.  
  1835.     /* Check stack underflow */
  1836.     if (s0 < sp) {
  1837.         if (io_source())
  1838.         (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  1839.         (VOID) fprintf(io_errf, "interpret: stack underflow\n");
  1840.         doabort();
  1841.     }
  1842.  
  1843.     /* Scan for the next symbol */
  1844.     spush(' ', INT32);
  1845.     doword();
  1846.  
  1847.     /* Exit top loop if end of input stream */
  1848.     if (io_eof()) {
  1849.         sdrop();
  1850.         return;
  1851.     }
  1852.  
  1853.     /* Search for the symbol in the current vocabulary search set*/
  1854.     dofind();
  1855.     flag = spop(INT32);
  1856.  
  1857. #ifdef CASTING
  1858.     /* Check for vocabulary casting prefix */
  1859.     for (cast = flag; !cast;) {
  1860.         CSTR s = tos.CSTR;
  1861.         INT32 l = strlen(s) - 1;
  1862.  
  1863.         /* Assume casting prefix */
  1864.         cast = TRUE;
  1865.  
  1866.         /* Check casting syntax, vocabulary name within parethesis */ 
  1867.         if ((s[0] == '(') && (s[l] == ')')) {
  1868.  
  1869.         /* Remove the parenthesis from the input string */
  1870.         s[l] = 0;
  1871.         unary(++, INT32);
  1872.  
  1873.         /* Search for the symbol again */
  1874.         dofind();
  1875.         flag = spop(INT32);
  1876.         
  1877.         /* If found check that its a vocabulary */
  1878.         if (flag) {
  1879.             ENTRY v = spop(ENTRY);
  1880.  
  1881.             /* Check that the symbol is really a vocabulary */
  1882.             if (v -> code == VOCABULARY) {
  1883.  
  1884.             /* Scan for a new symbol */
  1885.             spush(' ', INT32);
  1886.             doword();
  1887.  
  1888.             /* Exit top loop if end of input stream */
  1889.             if (io_eof()) {
  1890.                 sdrop();
  1891.                 return;
  1892.             }
  1893.  
  1894.             /* And look for it in the given vocabulary */
  1895.             spush(v, ENTRY);
  1896.             dolookup();
  1897.             flag = spop(INT32);
  1898.             cast = flag;
  1899.             }
  1900.         }
  1901.         else {
  1902.             /* Restore string after vocabulary name test */
  1903.             s[l] = ')';
  1904.             unary(--, INT32);
  1905.         }
  1906.         }
  1907.     }
  1908. #endif
  1909.     
  1910.     /* If found then execute or thread the symbol */
  1911.     if (flag) {
  1912.         if (state.parameter == flag)
  1913.         dothread();
  1914.         else
  1915.         docommand();
  1916.     }
  1917.     else {
  1918.         /* Else check if it is a literal */
  1919.         dorecognize();
  1920.         flag = spop(INT32);
  1921.         if (flag) {
  1922.         doliteral();
  1923.         }
  1924.         else {
  1925.         /* Print source file and line number */
  1926.         if (io_source())
  1927.             (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  1928.  
  1929.         /* If not print error message and abort */
  1930.         (VOID) fprintf(io_errf, "%s ??\n", tos.CSTR);
  1931.         doabort();
  1932.         }
  1933.     }
  1934.     }
  1935.     quited = TRUE;
  1936. }
  1937.  
  1938. NORMAL_CODE(interpret, forth83, "interpret", dointerpret);
  1939.  
  1940. VOID doquit()
  1941. {
  1942.     rinit();
  1943.     doleftbracket();
  1944.     dointerpret();
  1945. }
  1946.  
  1947. NORMAL_CODE(quit, interpret, "quit", doquit);
  1948.  
  1949. VOID doabort()
  1950. {
  1951.     /* Check if it is the foreground task */
  1952.     if (tp == foreground) {
  1953.     sinit(); 
  1954.     doleftbracket();
  1955.     io_flush();
  1956.     }
  1957.  
  1958.     /* Terminate aborted tasks */
  1959.     doterminate();
  1960. }
  1961.  
  1962. NORMAL_CODE(abort_entry, quit, "abort", doabort);
  1963.  
  1964. VOID doabortquote()
  1965. {
  1966.     spush('"', INT32);
  1967.     doword();
  1968.     dosdup();
  1969.     snip();
  1970.     spush(&parenabortquote, CODE_ENTRY);
  1971.     dothread();
  1972.     docomma();
  1973. }
  1974.  
  1975. COMPILATION_IMMEDIATE_CODE(abortquote, abort_entry, "abort\"", doabortquote);
  1976.     
  1977.  
  1978. /* DICTIONARY ADDRESSES */
  1979.  
  1980. VOID dohere()
  1981. {
  1982.     spush(dp, PTR32);
  1983. }
  1984.  
  1985. NORMAL_CODE(here, abortquote, "here", dohere);
  1986.  
  1987. NORMAL_CONSTANT(pad, here, "pad", (INT32) thepad);
  1988.  
  1989. NORMAL_CONSTANT(tib, pad, "tib", (INT32) thetib);
  1990.  
  1991. VOID dotobody()
  1992. {
  1993.     tos.INT32 = tos.ENTRY -> parameter;
  1994. }
  1995.  
  1996. NORMAL_CODE(tobody, tib, ">body", dotobody);
  1997.  
  1998. VOID dodotname()
  1999. {
  2000.     ENTRY e = spop(ENTRY);
  2001.     
  2002.     (VOID) fprintf(io_outf, "%s", e -> name);
  2003. }
  2004.  
  2005. NORMAL_CODE(dotname, tobody, ".name", dodotname);
  2006.  
  2007. NORMAL_CONSTANT(cell, dotname, "cell", 4);
  2008.  
  2009. VOID docells()
  2010. {
  2011.     tos.INT32 <<= 2;
  2012. }
  2013.  
  2014. NORMAL_CODE(cells, cell, "cells", docells);
  2015.  
  2016. VOID docellplus()
  2017. {
  2018.     tos.INT32 += 4;
  2019. }
  2020.  
  2021. NORMAL_CODE(cellplus, cells, "cell+", docellplus);
  2022.  
  2023.  
  2024. /* COMPILER AND INTERPRETER WORDS */
  2025.  
  2026. VOID dosharpif()
  2027. {
  2028.     INT32 symbol;
  2029.     BOOL flag;
  2030.  
  2031.     flag = spop(BOOL);
  2032.  
  2033.     if (!flag) {
  2034.     do {
  2035.         spush(' ', INT32);
  2036.         doword();
  2037.         symbol = spop(INT32);
  2038.         if (STREQ(symbol, "#if")) {
  2039.         dosharpelse();
  2040.         spush(' ', INT32);
  2041.         doword();
  2042.         symbol = spop(INT32);
  2043.         }
  2044.     } while (!((STREQ(symbol, "#else") || STREQ(symbol, "#then"))));
  2045.     }
  2046. }
  2047.  
  2048. IMMEDIATE_CODE(sharpif, cellplus, "#if", dosharpif);
  2049.  
  2050. VOID dosharpelse()
  2051. {
  2052.     INT32 symbol;
  2053.     
  2054.     do {
  2055.     spush(' ', INT32);
  2056.     doword();
  2057.     symbol = spop(INT32);
  2058.     if (STREQ(symbol, "#if")) {
  2059.         dosharpelse();
  2060.         spush(' ', INT32);
  2061.         doword();
  2062.         symbol = spop(INT32);
  2063.     }
  2064.     } while (!STREQ(symbol, "#then"));
  2065. }
  2066.  
  2067. IMMEDIATE_CODE(sharpelse, sharpif, "#else", dosharpelse);
  2068.  
  2069. VOID dosharpthen()
  2070. {
  2071.  
  2072. }
  2073.  
  2074. IMMEDIATE_CODE(sharpthen, sharpelse, "#then", dosharpthen);
  2075.  
  2076. VOID dosharpifdef()
  2077. {
  2078.     spush(' ', INT32);
  2079.     doword();
  2080.     dofind();
  2081.     doswap();
  2082.     dodrop();
  2083.     dosharpif();
  2084. }
  2085.  
  2086. IMMEDIATE_CODE(sharpifdef, sharpthen, "#ifdef", dosharpifdef);
  2087.  
  2088. VOID dosharpifundef()
  2089. {
  2090.     spush(' ', INT32);
  2091.     doword();
  2092.     dofind();
  2093.     doswap();
  2094.     dodrop();
  2095.     dozeroequals();
  2096.     dosharpif();
  2097. }
  2098.  
  2099. IMMEDIATE_CODE(sharpifundef, sharpifdef, "#ifundef", dosharpifundef);
  2100.  
  2101. VOID dosharpinclude()
  2102. {
  2103.     INT32 flag;
  2104.     CSTR  fname;
  2105.     
  2106.     spush(' ', INT32);
  2107.     doword();
  2108.     fname = spop(CSTR);
  2109.     if (flag = io_infile(fname) == IO_UNKNOWN_FILE) {
  2110.     if (io_source())
  2111.         (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  2112.     (VOID) fprintf(io_errf, "%s: file not found\n", fname);
  2113.     }
  2114.     else {
  2115.     if (flag == IO_TOO_MANY_FILES) {
  2116.         if (io_source())
  2117.         (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  2118.         (VOID) fprintf(io_errf, "%s: too many files open\n", fname);
  2119.     }
  2120.     }
  2121. }
  2122.  
  2123. NORMAL_CODE(sharpinclude, sharpifundef, "#include", dosharpinclude);
  2124.  
  2125. VOID dosharppath()
  2126. {
  2127.     INT32 flag;
  2128.     
  2129.     spush(' ', INT32);
  2130.     doword();
  2131.     if (flag = io_path(tos.CSTR, IO_PATH_FIRST) == IO_UNKNOWN_PATH) {
  2132.     if (io_source())
  2133.         (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  2134.     (VOID) fprintf(io_errf, "%s: unknown environment variable\n", tos.CSTR);
  2135.     }
  2136.     else {
  2137.     if (flag == IO_TOO_MANY_PATHS) {
  2138.         if (io_source())
  2139.         (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  2140.         (VOID) fprintf(io_errf, "%s: too many paths defined\n", tos.CSTR);
  2141.     }
  2142.     }
  2143.     dodrop();
  2144. }
  2145.  
  2146. NORMAL_CODE(sharppath, sharpinclude, "#path", dosharppath);
  2147.  
  2148. VOID doparen()
  2149. {
  2150.     CHAR c;
  2151.     
  2152.     while (c = io_getchar())
  2153.     if (io_eof()) {
  2154.         if (io_source())
  2155.         (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  2156.         (VOID) fprintf(io_errf, "kernel: end of file during comment\n");
  2157.         return;
  2158.     }
  2159.     else
  2160.         if (c == ')') return;
  2161.         else
  2162.         if (c == '(') {
  2163.             if (io_source())
  2164.             (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  2165.             (VOID) fprintf(io_errf, "kernel: warning balanced comment\n");
  2166.             doparen();
  2167.         }
  2168. }
  2169.  
  2170. IMMEDIATE_CODE(paren, sharppath, "(", doparen);
  2171.  
  2172. VOID dobackslash()
  2173. {
  2174.     io_skip('\n');
  2175. }
  2176.  
  2177. IMMEDIATE_CODE(backslash, paren, "\\", dobackslash);
  2178.  
  2179. VOID docomma()
  2180. {
  2181.     *dp++ = spop(INT32);
  2182. }
  2183.  
  2184. NORMAL_CODE(comma, backslash, ",", docomma);
  2185.  
  2186. VOID doallot()
  2187. {
  2188.     INT32 n;
  2189.  
  2190.     n = spop(INT32);
  2191.     dp = (PTR32) ((PTR8) dp + n);
  2192. }
  2193.  
  2194. NORMAL_CODE(allot, comma, "allot", doallot);
  2195.  
  2196. VOID doalign()
  2197. {
  2198.     align(dp);
  2199. }
  2200.  
  2201. NORMAL_CODE(align_entry, allot, "align", doalign);
  2202.  
  2203. VOID dodoes()
  2204. {
  2205.     if (theframed != NIL) {
  2206.     spush(&parenunlinkdoes, CODE_ENTRY);
  2207.     }
  2208.     else {
  2209.     spush(&parendoes, CODE_ENTRY);
  2210.     }
  2211.     dothread();
  2212.     doremovelocals();
  2213. }
  2214.  
  2215. COMPILATION_IMMEDIATE_CODE(does, align_entry, "does>", dodoes);
  2216.  
  2217. VOID doimmediate()
  2218. {
  2219.     current -> last -> mode |= IMMEDIATE;
  2220. }
  2221.  
  2222. NORMAL_CODE(immediate, does, "immediate", doimmediate);
  2223.  
  2224. VOID doexecution()
  2225. {
  2226.     current -> last -> mode |= EXECUTION;
  2227. }
  2228.  
  2229. NORMAL_CODE(execution, immediate, "execution", doexecution);
  2230.  
  2231. VOID docompilation()
  2232. {
  2233.     current -> last -> mode |= COMPILATION;
  2234. }
  2235.  
  2236. NORMAL_CODE(compilation, execution, "compilation", docompilation);
  2237.  
  2238. VOID doprivate()
  2239. {
  2240.     current -> last -> mode |= PRIVATE;
  2241. }
  2242.  
  2243. NORMAL_CODE(private_entry, compilation, "private", doprivate);
  2244.  
  2245. VOID dorecognizer()
  2246. {
  2247.     current -> recognizer = current -> last;
  2248. }
  2249.  
  2250. NORMAL_CODE(recognizer, private_entry, "recognizer", dorecognizer);
  2251.  
  2252. VOID dobracketcompile()
  2253. {
  2254.     dotick();
  2255.     dothread();
  2256. }
  2257.  
  2258. COMPILATION_IMMEDIATE_CODE(bracketcompile, recognizer, "[compile]", dobracketcompile);
  2259.  
  2260. VOID docompile()
  2261. {
  2262.     spush(*ip++, INT32);
  2263.     dothread();
  2264. }
  2265.  
  2266. COMPILATION_CODE(compile, bracketcompile, "compile", docompile);
  2267.  
  2268. VOID doqcompile()
  2269. {
  2270.     if (state.parameter) docompile();
  2271. }
  2272.  
  2273. COMPILATION_CODE(qcompile, compile, "?compile", doqcompile);
  2274.  
  2275. NORMAL_VARIABLE(state, qcompile, "state", FALSE);
  2276.  
  2277. VOID docompiling()
  2278. {
  2279.     spush(state.parameter, INT32);
  2280. }
  2281.  
  2282. NORMAL_CODE(compiling, state, "compiling", docompiling);
  2283.  
  2284. VOID doliteral()
  2285. {
  2286.     if (state.parameter) {
  2287.     spush(&parenliteral, CODE_ENTRY);
  2288.     dothread();
  2289.     docomma();
  2290.     }
  2291. }
  2292.  
  2293. COMPILATION_IMMEDIATE_CODE(literal, compiling, "literal", doliteral);
  2294.  
  2295. VOID doleftbracket()
  2296. {
  2297.     state.parameter = FALSE;
  2298. }
  2299.  
  2300. IMMEDIATE_CODE(leftbracket, literal, "[", doleftbracket);
  2301.  
  2302. VOID dorightbracket()
  2303. {
  2304.     state.parameter = TRUE;
  2305. }
  2306.  
  2307. NORMAL_CODE(rightbracket, leftbracket, "]", dorightbracket);
  2308.  
  2309. VOID doword()
  2310. {
  2311.     CHAR brkchr;
  2312.  
  2313.     brkchr = (CHAR) spop(INT32);
  2314.     (VOID) io_skipspace();
  2315.     (VOID) io_scan(thetib, brkchr);
  2316.     spush(thetib, CSTR);
  2317. }
  2318.  
  2319. NORMAL_CODE(word_entry, rightbracket, "word", doword);
  2320.  
  2321.  
  2322. /* VOCABULARIES */
  2323.  
  2324. NORMAL_CONSTANT(context_entry, word_entry, "context", (INT32) context);
  2325.  
  2326. NORMAL_CONSTANT(current_entry, context_entry, "current", (INT32) ¤t);
  2327.  
  2328. VOID dolast()
  2329. {
  2330.     spush((theframed ? theframed : current -> last), ENTRY);
  2331. }
  2332.  
  2333. NORMAL_CODE(last, current_entry, "last", dolast);
  2334.  
  2335. VOID dodefinitions()
  2336. {
  2337.     current = context[0];}
  2338.  
  2339.  
  2340. NORMAL_CODE(definitions, last, "definitions", dodefinitions);
  2341.  
  2342. VOID doonly()
  2343. {
  2344.     INT32 v;
  2345.  
  2346.     /* Flush the entry cache */
  2347.     spush(FALSE, BOOL);
  2348.     dorestore();
  2349.  
  2350.     /* Remove all vocabularies except the first */
  2351.     for (v = 1; v < CONTEXTSIZE; v++) context[v] = NIL;
  2352.  
  2353.     /* And make it definition vocabulary */
  2354.     current = context[0];
  2355. }
  2356.  
  2357. NORMAL_CODE(only, definitions, "only", doonly);
  2358.  
  2359. VOID doseal()
  2360. {
  2361.     INT32 v;
  2362.  
  2363.     /* Flush the entry cache */
  2364.     spush(FALSE, BOOL);
  2365.     dorestore();
  2366.  
  2367.     /* Remove the first vocabulary */
  2368.     for (v = 0; context[v] = context[v + 1]; v++);
  2369. }
  2370.  
  2371. NORMAL_CODE(seal, only, "seal", doseal);
  2372.  
  2373. VOID dorestore()
  2374. {
  2375.     register INT32 i;        /* Iteration variable */
  2376.     register ENTRY e;        /* Pointer to parameter entry */
  2377.     register ENTRY p;        /* Pointer to current entry */
  2378.  
  2379.     /* Access parameter and check if an entry */
  2380.     e = spop(ENTRY);
  2381.     if (e) {
  2382.  
  2383.     /* Flush all enties until the parameter symbol */
  2384.     for (p = current -> last; p && (p != e); p = p -> link)
  2385.         cache[hash(p -> name)] = NIL;
  2386.  
  2387.     /* If the entry was found remove all symbols until this entry */
  2388.     if (p == e) current -> last = e;
  2389.     }
  2390.     else {
  2391.     
  2392.     /* Flush the entry cache */
  2393.     for (i = 0; i < CACHESIZE; i++) cache[i] = NIL;
  2394.     }
  2395. }
  2396.  
  2397. NORMAL_CODE(restore, seal, "restore", dorestore);
  2398.  
  2399. VOID dotick()
  2400. {
  2401.     BOOL flag;
  2402.  
  2403.     spush(' ', INT32);
  2404.     doword();
  2405.     dofind();
  2406.     flag = spop(BOOL);
  2407.     if (!flag) {
  2408.     /* Print source file and line number */
  2409.     if (io_source())
  2410.         (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  2411.  
  2412.     /* If not print error message and abort */
  2413.     (VOID) fprintf(io_errf, "%s ??\n", tos.CSTR);
  2414.     doabort();
  2415.     }
  2416. }
  2417.  
  2418. NORMAL_CODE(tick, restore, "'", dotick);
  2419.  
  2420. VOID dobrackettick()
  2421. {
  2422.     dotick();
  2423.     doliteral();
  2424. }
  2425.  
  2426. COMPILATION_IMMEDIATE_CODE(brackettick, tick, "[']", dobrackettick);
  2427.  
  2428. VOID dolookup() 
  2429. {
  2430.     VOCABULARY_ENTRY v;        /* Search vocabulary */
  2431.     register ENTRY e;        /* Search entry */
  2432.     register CSTR s;        /* And string */
  2433.     
  2434.     /* Fetch parameters and initate entry pointer */
  2435.     v = (VOCABULARY_ENTRY) spop(PTR32);
  2436.     s = tos.CSTR;
  2437.     
  2438.     /* Iterate over the linked list of entries */
  2439.     for (e = v -> last; e; e = e -> link)
  2440.  
  2441.     /* Compare the symbol and entry string */
  2442.     if (STREQ(s, e -> name)) {
  2443.  
  2444.         /* Check if the entry is currently visible */
  2445.         if (visible(e, v)) {
  2446.         /* Return the entry and compilation mode */
  2447.         tos.ENTRY = e;
  2448.         spush((e -> mode & IMMEDIATE ? 1 : -1), INT32);
  2449.         return;
  2450.         }
  2451.     }
  2452.     spush(FALSE, BOOL);
  2453. }
  2454.  
  2455. NORMAL_CODE(lookup, brackettick, "lookup", dolookup);
  2456.  
  2457. #ifdef PROFILE
  2458. VOID docollision()
  2459. {
  2460.     /* Add collision statistics to profile information */
  2461. }
  2462. #endif
  2463.  
  2464. VOID dofind()
  2465. {
  2466.     ENTRY e;            /* Entry in the entry cache */
  2467.     CSTR  n;            /* Name string of entry to be found */
  2468.     INT32 v;            /* Index into vocabulary set */
  2469.     
  2470.     /* Access the string to be found */
  2471.     n = tos.CSTR;
  2472.  
  2473.     /* Check for cached entry */
  2474.     if (e = cache[hash(n)]) {
  2475.  
  2476.     /* Compare the string and the entry name */
  2477.     if (STREQ(tos.CSTR, e -> name)) {
  2478.  
  2479.         /* Check if the entry is currently visible */
  2480.         if (!(((e -> mode & COMPILATION) && (!state.parameter)) ||
  2481.           ((e -> mode & EXECUTION) && (state.parameter)))) {
  2482.         tos.ENTRY = e;
  2483.         spush((e -> mode & IMMEDIATE ? 1 : -1), INT32);
  2484.         return;
  2485.         }
  2486.     }
  2487. #ifdef PROFILE
  2488.     else {
  2489.         docollision();
  2490.     }
  2491. #endif    
  2492.     }
  2493.     
  2494.     /* For each vocabulary in the current search chain */
  2495.     for (v = 0; context[v] && v < CONTEXTSIZE; v++) {
  2496.     spush(context[v], VOCABULARY_ENTRY);
  2497.     dolookup();
  2498.     if (tos.INT32) {
  2499.         cache[hash(n)] = snth(0).ENTRY;
  2500.         return;
  2501.     }
  2502.     else {
  2503.         sdrop();
  2504.     }
  2505.     }
  2506.     spush(FALSE, BOOL);
  2507. }
  2508.  
  2509. NORMAL_CODE(find, lookup, "find", dofind);
  2510.  
  2511. VOID dorecognize()
  2512. {
  2513.     INT32 v;            /* Vocabulary index */
  2514.     ENTRY r;            /* Recognizer function */
  2515.  
  2516.     for (v = 0; context[v] && v < CONTEXTSIZE; v++) { 
  2517.     
  2518.     /* Check if a recognizer function is available */
  2519.     if (r = context[v] -> recognizer) {
  2520.         spush(r, ENTRY);
  2521.         docommand();
  2522.         if (tos.INT32) {
  2523.         return;
  2524.         }
  2525.         else {
  2526.         sdrop();
  2527.         }
  2528.     }
  2529.     }
  2530.  
  2531.     /* The string was not a literal symbol */
  2532.     spush(FALSE, BOOL);
  2533. }
  2534.  
  2535. NORMAL_CODE(recognize, find, "recognize", dorecognize);
  2536.  
  2537. VOID doforget()
  2538. {
  2539.     dotick();
  2540.     tos.ENTRY = tos.ENTRY -> link; 
  2541.     dorestore();
  2542. }
  2543.  
  2544. NORMAL_CODE(forget, recognize, "forget", doforget);
  2545.  
  2546. VOID dowords()
  2547. {
  2548.     ENTRY e;            /* Pointer to entries */
  2549.     INT32 v;            /* Index into vocabulary set */
  2550.     INT32 l;            /* String length */
  2551.     INT32 s;            /* Spaces between words */
  2552.     INT32 c;            /* Column counter */
  2553.     INT32 i;            /* Loop index */
  2554.     
  2555.     /* Iterate over all vocabularies in the search set */
  2556.     for (v = 0; v < CONTEXTSIZE && context[v]; v++) {
  2557.  
  2558.     /* Print vocabulary name */
  2559.     (VOID) fprintf(io_outf, "VOCABULARY %s", context[v] -> name);
  2560.     if (context[v] == current) (VOID) fprintf(io_outf, " DEFINITIONS");
  2561.     (VOID) fputc('\n', io_outf);
  2562.  
  2563.     /* Access linked list of enties and initiate column counter */
  2564.     c = 0;
  2565.  
  2566.     /* Iterate over all entries in the vocabulary */
  2567.     for (e = context[v] -> last; e; e = e -> link) {
  2568.  
  2569.         /* Check if the entry is current visible */
  2570.         if (visible(e, context[v])) {
  2571.         
  2572.         /* Print the entry string. Check that space is available */
  2573.         l = strlen(e -> name);
  2574.         s = (c ? (COLUMNWIDTH - (c % COLUMNWIDTH)) : 0);
  2575.         c = c + s + l;
  2576.         if (c < LINEWIDTH) {
  2577.             for (i = 0; i < s; i++) (VOID) fputc(' ', io_outf); 
  2578.         }
  2579.         else {
  2580.             (VOID) fputc('\n', io_outf);
  2581.             c = l;
  2582.         }
  2583.         (VOID) fprintf(io_outf, "%s", e -> name);
  2584.         }
  2585.     }
  2586.  
  2587.     /* End the list of words and separate the vocabularies */
  2588.     (VOID) fputc('\n', io_outf);
  2589.     (VOID) fputc('\n', io_outf);
  2590.     }
  2591. }
  2592.  
  2593. IMMEDIATE_CODE(words, forget, "words", dowords);
  2594.  
  2595.  
  2596. /* DEFINING NEW VOCABULARY ENTRIES */
  2597.  
  2598. ENTRY make_entry(name, code, mode, parameter)
  2599.     CSTR name;            /* String for the new entry */
  2600.     INT32 code, mode, parameter; /* Entry parameters */
  2601. {
  2602.     /* Allocate space for the entry */
  2603.     ENTRY e;
  2604.  
  2605.     /* Check type of entry to allocate */
  2606.     if (code == VOCABULARY)
  2607.     e = (ENTRY) malloc(sizeof(vocabulary_entry));
  2608.     else
  2609.     e = (ENTRY) malloc(sizeof(entry));
  2610.  
  2611.     /* Insert into the current vocabulary and set parameters */
  2612.     e -> link = current -> last;
  2613.     current -> last = e;
  2614.  
  2615.     /* Set entry parameters */
  2616.     e -> name = (CSTR) strcpy(malloc((unsigned) strlen(name) + 1), name);
  2617.     e -> code = code;
  2618.     e -> mode = mode;
  2619.     e -> parameter = parameter;
  2620.     if (code == VOCABULARY)
  2621.     ((VOCABULARY_ENTRY) e) -> recognizer = NIL;
  2622.     
  2623.     /* Check for entry caching */
  2624.     if (current == context[0])
  2625.     cache[hash(name)] = e;
  2626.     else
  2627.     cache[hash(name)] = NIL;
  2628.     
  2629.     /* Return pointer to the new entry */
  2630.     return e;
  2631. }
  2632.  
  2633. VOID doentry()
  2634. {
  2635.     INT32 flag;
  2636.     CSTR  name;
  2637.     INT32 code, mode, parameter;
  2638.     ENTRY forward;
  2639.     
  2640.     /* Try to find entry to check for forward declarations */
  2641.     forward = NIL;
  2642.     dodup();
  2643.     dofind();
  2644.     flag = spop(INT32);
  2645.     if (flag) {
  2646.     forward = spop(ENTRY);
  2647.     }
  2648.     else {
  2649.     sdrop();
  2650.     }
  2651.     
  2652.     /* Access name, code, mode and parameter field parameters */
  2653.     name = spop(CSTR);
  2654.     code = spop(INT32);
  2655.     mode = spop(INT32);
  2656.     parameter = spop(INT32);
  2657.  
  2658.     /* Create the new entry */
  2659.     (VOID) make_entry(name, code, mode, parameter);
  2660.  
  2661.     /* If found and forward the redirect parameter field of initial entry */
  2662.     if (forward && forward -> code == FORWARD) {
  2663.     forward -> parameter = (INT32) current -> last;
  2664.     if (verbose) {
  2665.         if (io_source())
  2666.         (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  2667.         (VOID) fprintf(io_errf, "%s: forward definition resolved\n", forward -> name);
  2668.     }
  2669.     }
  2670. }
  2671.  
  2672. NORMAL_CODE(entry_entry, words, "entry", doentry);
  2673.  
  2674. VOID doforward()
  2675. {
  2676.     spush(0, INT32);
  2677.     spush(NORMAL, INT32);
  2678.     spush(FORWARD, INT32);
  2679.     spush(' ', INT32);
  2680.     doword();
  2681.     doentry();
  2682. }
  2683.  
  2684. NORMAL_CODE(forward, entry_entry, "forward", doforward);
  2685.  
  2686. VOID docode()
  2687. {
  2688.     spush(NORMAL, INT32);
  2689.     spush(CODE, INT32);
  2690.     spush(' ', INT32);
  2691.     doword();
  2692.     doentry();
  2693. }
  2694.  
  2695. NORMAL_CODE(code, forward, "code", docode);
  2696.  
  2697. VOID docolon()
  2698. {
  2699.     align(dp);
  2700.     dohere();
  2701.     spush(HIDDEN, INT32);
  2702.     spush(COLON, INT32);
  2703.     spush(' ', INT32);
  2704.     doword();
  2705.     doentry();
  2706.     dorightbracket();
  2707.     thelast = current -> last;
  2708. }
  2709.  
  2710. NORMAL_CODE(colon, code, ":", docolon);
  2711.  
  2712. VOID dosemicolon()
  2713. {
  2714.     if (theframed != NIL) {
  2715.     spush(&parenunlinksemicolon, CODE_ENTRY);
  2716.     }
  2717.     else {
  2718.     spush(&parensemicolon, CODE_ENTRY);
  2719.     }
  2720.     dothread();
  2721.     doleftbracket();
  2722.     doremovelocals();
  2723.     if (thelast != NIL) {
  2724.     thelast -> mode = NORMAL;
  2725.     if (current == context[0]) cache[hash(thelast -> name)] = thelast;
  2726.     thelast = NIL;
  2727.     }
  2728. }
  2729.  
  2730. COMPILATION_IMMEDIATE_CODE(semicolon, colon, ";", dosemicolon);
  2731.  
  2732. VOID docreate()
  2733. {
  2734.     align(dp);
  2735.     dohere();
  2736.     spush(NORMAL, INT32);
  2737.     spush(CREATE, INT32);
  2738.     spush(' ', INT32);
  2739.     doword();
  2740.     doentry();
  2741. }
  2742.  
  2743. NORMAL_CODE(create, semicolon, "create", docreate);
  2744.  
  2745. VOID dovariable()
  2746. {
  2747.     spush(0, INT32);
  2748.     spush(NORMAL, INT32);
  2749.     spush(VARIABLE, INT32);
  2750.     spush(' ', INT32);
  2751.     doword();
  2752.     doentry();
  2753. }
  2754.  
  2755. NORMAL_CODE(variable, create, "variable", dovariable);
  2756.  
  2757. VOID doconstant()
  2758. {
  2759.     spush(NORMAL, INT32);
  2760.     spush(CONSTANT, INT32);
  2761.     spush(' ', INT32);
  2762.     doword();
  2763.     doentry();
  2764. }
  2765.  
  2766. NORMAL_CODE(constant, variable, "constant", doconstant);
  2767.  
  2768. VOID dovocabulary()
  2769. {
  2770.     spush(&forth, VOCABULARY_ENTRY);
  2771.     spush(NORMAL, INT32);
  2772.     spush(VOCABULARY, INT32);
  2773.     spush(' ', INT32);
  2774.     doword();
  2775.     doentry();
  2776. }
  2777.  
  2778. NORMAL_CODE(vocabulary, constant, "vocabulary", dovocabulary);
  2779.  
  2780. VOID dofield()
  2781. {
  2782.     spush(NORMAL, INT32);
  2783.     spush(FIELD, INT32);
  2784.     spush(' ', INT32);
  2785.     doword();
  2786.     doentry();
  2787. }
  2788.  
  2789. NORMAL_CODE(field, vocabulary, "field", dofield);
  2790.  
  2791.  
  2792. /* INITIALIZATION OF THE KERNEL */
  2793.  
  2794. VOID kernel_initiate(last, first, users, parameters, returns)
  2795.     ENTRY first, last;
  2796.     INT32 users, parameters, returns;
  2797. {
  2798.     /* Link user symbols into vocabulary chain if given */
  2799.     if (first && last) {
  2800.     forth.last = last;
  2801.     first -> link = (ENTRY) &field;
  2802.     }
  2803.     
  2804.     /* Create the foreground task object */
  2805.     foreground = make_task(users, parameters, returns, (INT32) NIL);
  2806.     
  2807.     /* Assign task fields */
  2808.     foreground -> status = RUNNING;
  2809.     s0 = (PTR) foreground -> s0;
  2810.     sp = (PTR) foreground -> sp;
  2811.     r0 = foreground -> r0;
  2812.     rp = foreground -> rp;
  2813.     ip = foreground -> ip;
  2814.     fp = foreground -> fp;
  2815.     ep = foreground -> ep;
  2816.  
  2817.     /* Make the foreground task the current task */
  2818.     tp = foreground;
  2819. }
  2820.  
  2821. VOID kernel_finish()
  2822. {
  2823.     /* Future clean up function for kernel */
  2824. }
  2825.